perm filename VIOLA[1,LMM]1 blob sn#031673 filedate 1973-03-26 generic text, type C, neo UTF8
COMMENT ⊗   VALID 00012 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	OPEN (CP SYSFILE INPUT)
C00020 00003	                   ELSE (APPEND1 X (CAR L))
C00037 00004	              PLUS 1)
C00051 00005	DEFINE ((
C00067 00006	                          LABELED
C00082 00007	        (EQ (IDMULT X) @ MULT)))
C00084 00008	DEFINE ((
C00098 00009	          XLIST  (INSERTMARKERS
C00099 00010	              (LABELED L)))))
C00106 00011	ADVISE (((CATALOG3 BEFORE (IF (EQUAL ARG1 @ (0 3)) THEN (RETURN (LIST
C00116 00012	                  (REPLACE (LASTNODE# STRUC) (LASTNODE# B))
C00124 ENDMK
C⊗;
OPEN (CP SYSFILE INPUT)
RESTORE (CP)
CLOSE (CP)
FIXDEFINE ((COMPILE MACRO PRINT))
CLEANUP (ARRAY)
(LAMBDA NIL
    (BPSMOVE (DIFFERENCE (BPSLEFT) 12000))) NIL
RECORD (SUPERATOMPARTITION (SUPERATOMPARTS . REMAININGATOMS))
RECORD (FVPARTITION (NEWVL . FVR))
RECORD (STRUCFORM (ID$ . FORM))
RECORD (STRUCTURE (ID1 CTABLE UGRAPH LASTNODE# . GROUP))
RECORD (RADICAL (CENTER . ATTACHEDRADS))
RECORD (MAKECENTER (AFFLINK RADSTRUC . CUFFLINKS))
RECORD (IDDUMMY (ID . RESTOF-IDDUMMY))
RECORD (MARKER-REC (ATOMTYPE . OTHERMARKERS))
RECORD (CTENTRY (ID2 NODENUM MARKERS . NBRS))
RECORD (EDGE (NODE1 . NODE2))
RECORD (LOOPPARTITION (LOOPVL EDGELABELS . LOOPLABELS))
DEFAULT (STRUCFORM (ID$ FORM))
DEFAULT (STRUCTURE (GROUP (NIL)))
DEFAULT (STRUCTURE (ID1 STRUC))
DEFAULT (CTENTRY (MARKERS (NIL)))
DEFAULT (CTENTRY (ID2 CTE))
SPECIAL ((LASTNODE TRIVALENTCODES))
SPECIAL ((CATALOG-LIST))
SPECIAL ((XLATETABLE XLATN))
GSET (GRAPHFILE LISPOUT)
DEFINE ((
  (NUMPARTITIONS (LAMBDA (N NUMPARTS MINPART MAXPART)
        (IF (EQUAL NUMPARTS 1)
           THEN (IF (OR (GREATERP MINPART N) (LESSP MAXPART N))
                   THEN NIL
                 ELSE (LIST (LIST N)))
         ELSE (FOR NEW I
                := ((MAX
                      MINPART
                      (DIFFERENCE
                        N
                        (TIMES (SUB1 NUMPARTS) MAXPART)))
                    (MIN MAXPART (QUOTIENT N NUMPARTS)))
                  FOR NEW RESTPART
                    IN (NUMPARTITIONS
                        (DIFFERENCE N I)
                        (SUB1 NUMPARTS)
                        I
                        MAXPART) LIST  (CONS I RESTPART)))))
  ))
DEFINE ((
  (CLPARTITIONS (LAMBDA (CL PARTSIZES)
        (IF (NULL PARTSIZES) THEN (LIST NIL)
         ELSEIF (NULL (CDR PARTSIZES)) THEN (LIST (LIST CL))
         ELSEIF (ZEROP (CAR PARTSIZES))
           THEN (MAPCAR
                  (CLPARTITIONS CL (CDR PARTSIZES))
                  (FUNCTION (LAMBDA (X)
                      (CONS NIL X))))
         ELSEIF (EQUAL (CAR PARTSIZES) (CADR PARTSIZES))
           THEN (PROG (N THISPART)
                    (SETQ N 1)
                    (SETQ THISPART (CAR PARTSIZES))
                    (FOR PARTSIZES ON (CDR PARTSIZES)
                      WHILE (EQUAL (CAR PARTSIZES) THISPART)
                        DO  (SETQ N (ADD1 N)))
                    (IF (NULL PARTSIZES)
                       THEN (RETURN (CL=PARTS CL N THISPART)))
                    (RETURN (FOR NEW BIGPART
                      IN (CLPARTS CL (TIMES N THISPART))
                        AS NEW RESTPARTSLIST
                          IS (CLPARTITIONS
                              (CLDIFF CL BIGPART)
                              PARTSIZES)
                            FOR NEW LITTLEPARTS
                              IN (CL=PARTS BIGPART N THISPART)
                                FOR NEW RESTPARTS
                                  IN RESTPARTSLIST
                                    XLIST  (APPEND
                                        LITTLEPARTS
                                        RESTPARTS))))
         ELSE (FOR NEW PART IN (CLPARTS CL (CAR PARTSIZES))
                FOR NEW PARTS
                  IN (CLPARTITIONS
                      (CLDIFF CL PART)
                      (CDR PARTSIZES)) XLIST  (CONS PART PARTS)))))
  ))
DEFINE ((
  (CLPARTS (LAMBDA (CL PARTSIZE)
        (IF (ZEROP PARTSIZE) THEN (LIST NIL)
         ELSEIF (NULL (CDR CL))
           THEN (LIST (LIST (CONS (CAAR CL) PARTSIZE)))
         ELSE (PROG (SIZE)
                  (SETQ SIZE
                    (DIFFERENCE PARTSIZE (CLCOUNT (CDR CL))))
                  (RETURN (FOR NEW X
                    := ((MAX SIZE 1) (MIN PARTSIZE (CDAR CL)))
                      FOR NEW PART
                        IN (CLPARTS
                            (CDR CL)
                            (DIFFERENCE PARTSIZE X))
                          XLIST
                            FIRST (IF (LESSP 0 SIZE) THEN NIL
                               ELSE (CLPARTS (CDR CL) PARTSIZE))
                               (CONS (CONS (CAAR CL) X) PART)))))))
  ))
DEFINE ((
  (CL=PARTS (LAMBDA (CL NPARTS PARTSIZE)
        (IF (NULL (CDR CL))
           THEN (SETQ CL (LIST (CONS (CAAR CL) PARTSIZE)))
                (LIST (FOR NEW I := (1 NPARTS) XLIST  CL))
         ELSE (FOR NEW X
                IN (NUMPARTITIONS (CDAR CL) NPARTS 0 PARTSIZE)
                  FOR NEW Y
                    IN (CLPARTITIONS
                        (CDR CL)
                        (FOR NEW XX IN X
                          LIST  (DIFFERENCE PARTSIZE XX)))
                      XLIST  (FOR NEW XX IN X AS NEW YY IN Y
                          LIST  (IF (ZEROP XX) THEN YY
                             ELSE (CONS (CONS (CAAR CL) XX) YY)))))))
  ))
DEFINE ((
  (CLDIFF (LAMBDA (CL1 CL2)
        (IF (NULL CL2) THEN CL1
         ELSEIF (EQUAL (CAR CL1) (CAR CL2))
           THEN (CLDIFF (CDR CL1) (CDR CL2))
         ELSEIF (EQ (CAAR CL1) (CAAR CL2))
           THEN (CONS
                  (CONS
                    (CAAR CL1)
                    (DIFFERENCE (CDAR CL1) (CDAR CL2)))
                  (CLDIFF (CDR CL1) (CDR CL2)))
         ELSE (CONS (CAR CL1) (CLDIFF (CDR CL1) CL2)))))
  ))
DEFINE ((
  (CLCOUNT (LAMBDA (CL)
        (FOR NEW X IN CL PLUS  (CDR X))))
  ))
DEFINE ((
  (CLPARTITIONSN (LAMBDA (CL N MINPARTSIZE MAXPARTSIZE)
        (FOR NEW PARTSIZES
          IN (NUMPARTITIONS (CLCOUNT CL) N MINPARTSIZE MAXPARTSIZE)
            NCONC FIRST NIL
               (CLPARTITIONS CL PARTSIZES))))
  ))
DEFINE ((
  (CLCREATE (LAMBDA (L)
        (PROG (CL)
            (FOR NEW X IN L DO  (SETQ CL (CLINSERT X CL)))
            (RETURN CL))))
  ))
DEFINE ((
  (CLINSERT (LAMBDA (ITEM CL)
        (IF (NOT CL) THEN (LIST (CONS ITEM 1))
         ELSEIF (EQUAL ITEM (CAAR CL))
           THEN (REPLACE (CDR (CAR CL)) (ADD1 (CDR (CAR CL))))
                CL
         ELSEIF (LEQ ITEM (CAAR CL)) THEN (CONS (CONS ITEM 1) CL)
         ELSE (REPLACE (CDR CL) (CLINSERT ITEM (CDR CL))))))
  ))
DEFINE ((
  (GENRAD (LAMBDA (CL)
        (IF (AND (NULL (CDR CL)) (EQUAL (CDAR CL) 1))
           THEN (PERMRADS (CAAR CL) NIL T)
         ELSE (FOR NEW OLDCL ON CL AS NEW CENTER IS (CAAR OLDCL)
                AS NEW NEWCL
                  IS (CLDIFF CL (LIST (CONS CENTER 1)))
                    FOR NEW DEGREE
                      := (1 (MIN
                          (CLCOUNT NEWCL)
                          (SUB1 (VALENCE CENTER))))
                        FOR NEW RADS IN (GENRADS NEWCL DEGREE)
                          NCONC FIRST NIL
                             (PERMRADS CENTER RADS T)))))
  ))
DEFINE ((
  (GENRADS (LAMBDA (CL N)
        (IF (NULL CL) THEN (LIST NIL)
         ELSE (FOR NEW PARTITION
                IN (CLPARTITIONSN CL N 1 (CLCOUNT CL))
                  NCONC FIRST NIL
                     (GENRADLIST PARTITION)))))
  ))
DEFINE ((
  (GENRADLIST (LAMBDA (CLLIST)
        (GROUPRADS (GENRADLIST1 (CLCREATE CLLIST)))))
  ))
DEFINE ((
  (GENRADLIST1 (LAMBDA (CLCL)
        (FOR NEW CLNUMPAIR IN CLCL
          LIST  (CONS (GENRAD (CAR CLNUMPAIR)) (CDR CLNUMPAIR)))))
  ))
DEFINE ((
  (GROUPRADS (LAMBDA (RADCLIST)
        (IF (NULL RADCLIST) THEN (LIST NIL)
         ELSE (GROUPRADS1
                (CAAR RADCLIST)
                (CDAR RADCLIST)
                (GROUPRADS (CDR RADCLIST))))))
  ))
DEFINE ((
  (GROUPRADS1 (LAMBDA (RADLIST N RADSLIST)
        (IF (ZEROP N) THEN RADSLIST
         ELSE (FOR RADLIST ON RADLIST
                FOR NEW RADS
                  IN (GROUPRADS1 RADLIST (SUB1 N) RADSLIST)
                    LIST  (CONS (CAR RADLIST) RADS)))))
  ))
DEFINE ((
  (VALENCE (LAMBDA (AT)
        (COND
          ((NUMBERP AT) AT)
          ((ATOM AT) (GET AT @ VALENCE))
          (T (FREEVALENCESIZE AT)))))
  ))
DEFINE ((
  (GENMOL (LAMBDA (CL)
        (PROG (MINDEG RESULT NATOMS)
            (IF (EQUAL 1 (SETQ NATOMS (CLCOUNT CL)))
               THEN (RETURN (PERMRADS (CAAR CL) NIL NIL))
             ELSEIF (EVENP NATOMS)
               THEN (FOR NEW PART
                      IN (CL=PARTS CL 2 (QUOTIENT NATOMS 2))
                        FOR NEW RADS IN (GENRADLIST PART)
                          DO  (SETQ RESULT
                              (APPEND
                                (PERMRADS NIL RADS NIL)
                                RESULT)))
                    (SETQ MINDEG 3)
             ELSE (SETQ MINDEG 2))
            (SETQ NATOMS (SUB1 NATOMS))
            (FOR NEW PAIR IN CL AS NEW CENTER IS (CAR PAIR)
              AS NEW NEWCL IS (CLDIFF CL (LIST (CONS CENTER 1)))
                FOR NEW DEG
                  := (MINDEG (MIN (VALENCE CENTER) NATOMS))
                    FOR NEW P
                      IN (CLPARTITIONSN
                          NEWCL
                          DEG
                          1
                          (QUOTIENT NATOMS 2))
                        FOR NEW RADS IN (GENRADLIST P)
                          DO  (SETQ RESULT
                              (NCONC
                                (PERMRADS CENTER RADS NIL)
                                RESULT)))
            (RETURN RESULT))))
  ))
DEFINE ((
  (FIX+ (LAMBDA (X)
        (FIX (PLUS X 0.99))))
  ))
DEFINE ((
  (NUMPARTITIONS* (LAMBDA (U MN MAXIMA OCCURLIST)
        (IF (NULL (CDR OCCURLIST))
           THEN (NUMPARTITIONS U (CAR OCCURLIST) MN (CAR MAXIMA))
         ELSE (FOR NEW FIRST
                := ((FIX+ (MAX
                      MN
                      (DIFFERENCE
                        U
                        (FOR NEW X IN (CDR MAXIMA)
                          AS NEW Y IN (CDR OCCURLIST)
                            PLUS
                              FIRST (TIMES
                                  (SUB1 (CAR OCCURLIST))
                                  (CAR MAXIMA))
                                 (TIMES X Y)))))
                    (MIN
                      (CAR MAXIMA)
                      (QUOTIENT
                        (DIFFERENCE U (*PLUS (CDR OCCURLIST)))
                        (CAR OCCURLIST))))
                  FOR NEW REST
                    IN (IF (EQUAL (CAR OCCURLIST) 1)
                         THEN (NUMPARTITIONS*
                                (DIFFERENCE U FIRST)
                                1
                                (CDR MAXIMA)
                                (CDR OCCURLIST))
                       ELSE (NUMPARTITIONS*
                              (DIFFERENCE U FIRST)
                              FIRST
                              MAXIMA
                              (CONS
                                (SUB1 (CAR OCCURLIST))
                                (CDR OCCURLIST))))
                      XLIST  (CONS FIRST REST)))))
  ))
DEFINE ((
  (GROUPBY (LAMBDA (FN L)
        (IF (NULL L) THEN NIL
         ELSE (PROG (FNX GROUPCDR X)
                  (SETQ GROUPCDR (GROUPBY FN (CDR L)))
                  (IF (NULL (SETQ X
                    (ASSOC (SETQ FNX (FN (CAR L))) GROUPCDR NIL)))
                     THEN (RETURN (CONS
                            (LIST FNX (CAR L))
                            GROUPCDR))
                   ELSE (APPEND1 X (CAR L))
                        (RETURN GROUPCDR))))))
  ))
DEFINE ((
  (FVPARTITION1 (LAMBDA (N VL S)
        (COND
          ((NULL VL) (LIST NIL))
          (T (PROG (SUMREST)
              (SETQ SUMREST
                (FOR NEW X IN (CDR VL)
                  AS NEW SP := ((ADD1 S) 9999999)
                    PLUS  (TIMES SP X)))
              (RETURN (FOR NEW I
                := ((MAX 0 (DIFFERENCE N SUMREST))
                    (MIN N (TIMES (CAR VL) S)))
                  AS NEW PARTREST
                    IS (FVPARTITION1
                        (DIFFERENCE N I)
                        (CDR VL)
                        (ADD1 S))
                      FOR NEW FIRSTPART IN (FVPART1 I (CAR VL) S)
                        FOR NEW RESTPART IN PARTREST
                          XLIST  (CONS FIRSTPART RESTPART))))))))
  ))
DEFINE ((
  (FVPART1 (LAMBDA (N MAXSUM MAXOCCUR)
        (COND
          ((ZEROP MAXOCCUR) (LIST NIL))
          (T (FOR NEW I
            := ((MAX
                  0
                  (DIFFERENCE N (TIMES MAXSUM (SUB1 MAXOCCUR)))
                  (COMMENT I*MAXOCCUR + (MAXSUM-I) * (MAXOCCUR-1)
                   >=N I*MAXOCCUR+MAXSUM* (MAXOCCCUR-1) -I* (MXO-1)
                   OR I>=N-MAXSUM* (MAXOCCUR-1)))
                (MIN MAXSUM (QUOTIENT N MAXOCCUR)))
              FOR NEW REST
                IN (FVPART1
                    (DIFFERENCE N (TIMES I MAXOCCUR))
                    (DIFFERENCE MAXSUM I)
                    (SUB1 MAXOCCUR)) XLIST  (CONS I REST))))))
  ))
DEFINE ((
  (MINLOOPS (LAMBDA (VALENCELIST)
        (MAX
          0
          (PROG (MXV TD)
              (* SETQ TD MXV 0)
              (FOR NEW X IN (CDR VALENCELIST)
                AS NEW VALENCE := (3 999999)
                  WHEN
                    (NOT (ZEROP X))
              DO    (IF (GREATERP VALENCE MXV)
                       THEN (SETQ MXV VALENCE))
                    (SETQ TD (PLUS (TIMES X VALENCE) TD)))
              (RETURN (QUOTIENT (DIFFERENCE MXV TD) 2))))))
  ))
DEFINE ((
  (MAXLOOPS (LAMBDA (VALENCELIST)
        (MIN
          (CAR VALENCELIST)
          (FIX+ (FOR NEW W IN (CDDR VALENCELIST)
            AS NEW J := (2 99999) PLUS  (TIMES 0.5 W J))))))
  ))
DEFINE ((
  (MOLECULES (LAMBDA (CL U)
        (IF (ZEROP U) THEN (GENMOL CL)
         ELSE (FOR NEW SAP IN (SUPERATOMPARTITIONS CL U)
                FOR NEW S IN (SUPERATOMS (SUPERATOMPARTS SAP))
                  NCONC FIRST NIL
                     (GENMOL (APPEND
                      (CLCREATE S)
                      (REMAININGATOMS SAP)))))))
  ))
DEFINE ((
  (SUPERATOMPARTITIONS (LAMBDA (CL U)
        (PROG (CL1 SZ)
            (SETQ CL1
              (FOR NEW PR IN CL
                WHEN
                  (EQUAL (VALENCE (CAR PR)) 1)
            LIST PR))
            (SETQ CL (CLDIFF CL CL1))
            (RETURN (FOR NEW PARTSIZE
              := (2 (SETQ SZ (CLCOUNT CL)))
                FOR NEW VHAT IN (CLPARTS CL PARTSIZE)
                  AS NEW REMATS IS (APPEND CL1 (CLDIFF CL VHAT))
                    FOR NEW #PARTS := (1 (QUOTIENT PARTSIZE 2))
                      FOR NEW PARTITION
                        IN (CLPARTITIONSN VHAT #PARTS 2 9999999)
                          AS NEW VI IS (CLCREATE PARTITION)
                            AS NEW MXUI IS (MAXUNSATL VI)
                              WHEN
                          MXUI FOR NEW UI IN
                                (NUMPARTITIONS*
                                  U
                                  1
                                  MXUI
                                  (MAPCAR VI @ CDR))
                          XLIST (SUPERATOMPARTITION
                                  REMAININGATOMS
                                  =
                                  REMATS
                                  SUPERATOMPARTS
                                  =
                                  (PROG (CVI CVN M VI2 CUI VI3)
                                      (SETQ VI3 VI)
                                VILOOP(IF (NULL VI3)
                                         THEN (RETURN VI2))
                                      (SETQ CVI (CAAR VI3))
                                      (SETQ CVN (CDAR VI3))
                                      (SETQ VI3 (CDR VI3))
                                LOOPM (SETQ M 0)
                                LOOPCVN
                                      (SETQ M (ADD1 M))
                                      (SETQ CVN (SUB1 CVN))
                                      (SETQ CUI (CAR UI))
                                      (SETQ UI (CDR UI))
                                      (IF (AND
                                        (NOT (ZEROP CVN))
                                        (EQUAL CUI (CAR UI)))
                                         THEN (GO LOOPCVN))
                                      (SETQ VI2
                                        (CONS
                                          (CONS (CONS CUI CVI) M)
                                          VI2))
                                      (IF (ZEROP CVN)
                                         THEN (GO VILOOP)
                                       ELSE (GO LOOPM)))))))))
  ))
DEFINE ((
  (MAXUNSATL (LAMBDA (PC)
        (FOR NEW PART-NUM IN PC
          LIST  (PROG (N TD M)
                (* SETQ N TD M 0)
                (FOR NEW PR IN (CAR PART-NUM)
                  DO
                    (SETQ N (PLUS N (CDR PR)))
                    (SETQ TD
                      (PLUS TD (TIMES (CDR PR) (VALENCE (CAR PR)))))
                    (SETQ M (MAX M (VALENCE (CAR PR)))))
                (RETURN (FIX (TIMES
                  0.5
                  (PLUS
                    2
                    TD
                    (TIMES -2 N)
                    (MIN -1 (DIFFERENCE TD (TWICE M)))))))))))
  ))
DEFINE ((
  (SUPERATOMS (LAMBDA (UCL-COMP)
        (GROUPRADS (FOR NEW UCLN IN UCL-COMP
          LIST  (CONS (RINGS (CAAR UCLN) (CDAR UCLN)) (CDR UCLN))))))
  ))
DEFINE ((
  (COMPUTEFV (LAMBDA (U CL)
        (PROG (TD N)
            (* SETQ TD N 0)
            (FOR NEW PR IN CL
              DO
                (SETQ TD
                  (PLUS (TIMES (VALENCE (CAR PR)) (CDR PR)) TD))
                (SETQ N (PLUS (CDR PR) N)))
            (RETURN (PLUS 2 TD (TIMES -2 (PLUS N U)))))))
  ))
DEFINE ((
  (CLBYVALENCE (LAMBDA (CL)
        (PROG2
          (SETQ CL
            (GROUPBY
              (FUNCTION (LAMBDA (PR)
                  (VALENCE (CAR PR))))
              CL))
          (FOR NEW I := (2 (*MAX (MAPCAR CL @ CAR)))
            LIST  (ASSOC I CL NIL)))))
  ))
DEFINE ((
  (RINGS (LAMBDA (U CL)
        (PROG (FV)
            (SETQ FV (COMPUTEFV U CL))
            (SETQ CL (CLBYVALENCE CL))
            (RETURN (FOR NEW SKELETON
              IN (RINGSKELETONS FV (MAPCAR CL @ CLCOUNT))
                NCONC FIRST NIL
                   (STRUCTURESWITHATOMS CL SKELETON))))))
  ))
DEFINE ((
  (FVPARTITIONS (LAMBDA (FV VL)
        (FOR NEW FVP IN (FVPARTITION1 FV (CDR VL) 1)
          AS NEW FVR IS (ROWS FVP)
            XLIST  (FVPARTITION
                FVR
                =
                FVR
                NEWVL
                =
                (FOR NEW ROW IN FVR AS NEW COL IN (CONS NIL FVP)
                  AS NEW V IN VL
                    LIST  (PLUS V (*PLUS ROW) (MINUS (*PLUS COL))))))
         ))
  ))
DEFINE ((
  (RINGSKELETONS (LAMBDA (FV VL)
        (FOR NEW FVPART IN (FVPARTITIONS FV VL)
          FOR NEW STRUC IN (NOFV-RINGS (NEWVL FVPART))
            NCONC FIRST NIL
               (ATTACHFVS (FVR FVPART) STRUC))))
  ))
DEFINE ((
  (NOFV-RINGS (LAMBDA (VL)
        (PROG (MNLPS MXLPS SUMREST)
            (SETQ SUMREST (*PLUS (CDR VL)))
            (IF (ZEROP SUMREST)
               THEN (RETURN (SINGLERINGS (CAR VL)))
             ELSEIF (EQUAL SUMREST 1) THEN (RETURN (DAISIES VL)))
            (SETQ MNLPS (MINLOOPS VL))
            (SETQ MXLPS (MAXLOOPS VL))
            (RETURN (FOR NEW P := (MNLPS MXLPS)
              NCONC FIRST NIL
                 (KLOOPEDRINGS P VL))))))
  ))
DEFINE ((
  (DAISIES (LAMBDA (VL)
        (FOR NEW P
          IN (NUMPARTITIONS
              (CAR VL)
              (QUOTIENT
                (FOR NEW X IN (CDR VL) AS NEW I := (3 99999)
                  UNTIL (NOT (ZEROP X)) PROG2  I)
                2)
              1
              99999999) NCONC FIRST NIL
             (DAISY (CLCREATE P)))))
  ))
DEFINE ((
  (NOLOOPEDRINGS (LAMBDA (VL)
        (IF (ZEROP (CAR VL)) THEN (CATALOG (CDR VL))
         ELSE (PROG (BP)
                  (SETQ BP (BIVALENTPARTITIONS VL))
                  (RETURN (FOR NEW S IN (CATALOG (CDR VL))
                    FOR NEW P IN BP
                      NCONC FIRST NIL
                         (ATTACHBIVALENTS (CLCREATE P) S)))))))
  ))
DEFINE ((
  (TWICE (LAMBDA (X)
        (PLUS X X)))
  ))
DEFINE ((
  (ROWS (LAMBDA (LL)
        (IF (NOT LL) THEN @
                          (NIL)
         ELSE (CONS
                (MAPCAR LL @ CAR)
                (ROWS (MAPCAR (CDR LL) @ CDR))))))
  ))
DEFINE ((
  (BIVALENTPARTITIONS (LAMBDA (VL)
        (NUMPARTITIONS
          (CAR VL)
          (QUOTIENT
            (FOR NEW I := (3 9999) AS NEW X IN (CDR VL)
              PLUS  (TIMES I X))
            2)
          0
          (CAR VL))))
  ))
DEFINE ((
  (ISOMERS (LAMBDA (U CL)
        (FOR NEW X IN (MOLECULES CL U) AS NEW I := (1 99999)
          DO
            (TTAB 1)
            (PRIN1 I)
            (PRIN1 PERIOD)
            (TTAB 5)
            (PRINRAD X)
            (TERPRI))))
  ))
DEFLIST ((
  (C 4)
  (N 3)  (I 1) (CL 1) (BR 1) (F 1) (S 2) (P 5)
  (O 2)  (SI 4)
  (H 1)) VALENCE)
MACRO ((
  (STRUCTURE? (LAMBDA (X)
        (EQ (ID X) @ STRUC)))
  ))
MACRO ((
  (STRUCFORM? (LAMBDA (X)
        (EQ (ID X) @ FORM)))
  ))
DEFINE ((
  (FREEVALENCESIZE (LAMBDA (S)
        (IF (STRUCTURE? S)
           THEN (FOR NEW X IN (CTABLE S) FOR NEW Y IN (NBRS X)
                  WHEN
                    (EQ Y @ FV)
              PLUS 1)
         ELSEIF (STRUCFORM? S)
           THEN (IF (EQ (CAR (FORM S)) @ ATTACHFVS)
                   THEN (FOR NEW FVL IN (CADR (FORM S))
                          FOR NEW X IN FVL AS NEW I := (1 999999)
                            PLUS  (TIMES I X))
                 ELSE (FREEVALENCESIZE (CADDR (FORM S)))))))
  ))
DEFINE ((
  (NODES (LAMBDA (STRUC)
        (MAPCAR (CTABLE STRUC) (FUNCTION (LAMBDA (X)
            (NODENUM X))))))
  ))
DEFINE ((
  (COLLECTFV (LAMBDA (S)
        (FOR NEW CT IN (CTABLE S) FOR NEW X IN (NBRS CT)
          WHEN
            (EQ X @ FV)
      XLIST (NODENUM CT))))
  ))
DEFINE ((
  (TRIMZEROS (LAMBDA (L)
        (PROG (N)
            (RETURN (IF (NULL L) THEN NIL
             ELSEIF (ZEROP (SETQ N (*PLUS L))) THEN NIL
             ELSE (CONS (CAR L) (TRIMZEROS (CDR L))))))))
  ))
DEFINE ((
  (CATALOG (LAMBDA (L)
        (IF (AND
          (EQUAL (*PLUS (SETQ L (TRIMZEROS L))) 2)
          (EQUAL (CAR (LAST L)) 2))
           THEN (LIST (STRUCWITH2NODES (PLUS 2 (LENGTH L))))
         ELSE (CATALOG3 L))))
  ))
DEFINE ((
  (STRUCWITH2NODES (LAMBDA (N)
        (STRUCTURE
          UGRAPH
          =
          (CONS @ MBONDS N)
          CTABLE
          =
          (LIST
            (CTENTRY
              NODENUM
              =
              1
              NBRS
              =
              (FOR NEW I := (1 N) XLIST  2))
            (CTENTRY
              NODENUM
              =
              2
              NBRS
              =
              (FOR NEW I := (1 N) XLIST  1)))
          LASTNODE#
          =
          2)))
  ))
DEFINE ((
  (CATALOG3 (LAMBDA (TVL)
        (PROG (C)
            (COND
              ((NOT (ZEROP (*PLUS (CDR TVL)))) NIL)
              (T (SETQ C (NTH CATALOG-LIST (QUOTIENT (CAR TVL) 2)))))
            (RETURN (IF (AND C (CAR C)) THEN (CAR C)
             ELSE (LIST (STRUCFORM FORM=(CONS @ CATALOG   TVL))))))))
  ))
DEFINE ((
  (DAISY (LAMBDA (PART)
        (PROG (S C)
            (SETQ LASTNODE 1)
            (SETQ S
              (STRUCTURE
                UGRAPH=
         (CONS  @  DAISY     PART)
                CTABLE
                =
                (LIST (CTENTRY NODENUM = LASTNODE))
                LASTNODE#
                =
                LASTNODE))
            (SETQ C LASTNODE)
            (RETURN (LIST (FOR NEW PAIR IN PART
              FOR NEW I := (1 (CDR PAIR))
                PROG2  (SETQ S (PUTBIVN S C (CAR PAIR)))))))))
  ))
DEFINE ((
  (MAKECAT (LAMBDA (TVC)
        (FOR NEW X IN TVC AS NEW J IS (CAR X)
          LIST  (FOR NEW Y IN (CDR X) LIST  (TRIVGRAPH J Y)))))
  ))
DEFINE ((
  (TRIVGRAPH (LAMBDA (J L)
        (PROG (S X Y LL N)
            (SETQ LL L)
            (SETQ S (SINGLERING J))
            (SETQ X (FOR NEW I := (J 1 -1) XLIST  I))
            (FOR X ON X AS L ON L
              DO
                (SETQ N (PLUS (CHORDLENGTH (CAR L)) (CAR X)))
                (CONNECT (FINDCTE (CAR X) S) (FINDCTE N S) S)
                (SETQ X (DELETE N X)))
            (RETURN (STRUCTURE FROM S UGRAPH = (CONS J LL))))))
  ))
DEFINE ((
  (CHORDLENGTH (LAMBDA (X)
        (CDR (SASSOC
          X
          @ ((A . 1) (B . 2) (C . 3) (D . 4) (E . 5) (F . 6) (G . 7)
           (H . 8) (I . 9))
          NIL))))
  ))
GSET (TRIVALENTCODES ((2 (A)) (4 (B B) (A A)) (6 (B C B) (A A A) (A
   B B) (A C A) (C C C)) (8 (B C C B) (B D D B) (C E C C) (A A A A)
   (A A B B) (A A C A) (A B C B) (A B D A) (A C D B) (A D D A) (A E
   B B) (A E C A) (B B B B))))
DEFINE ((
  (SINGLERING (LAMBDA (N)
        (PROG (S)
            (SETQ LASTNODE 0)
            (SETQ S (BIVCHAIN N))
            (CONNECT
              (FINDCTE (FIRSTOFNODES S) S)
              (FINDCTE (LASTOFNODES S) S))
            (RETURN (STRUCTURE
              FROM
              S
              UGRAPH
              =
        (CONS @  SINGLERING     N))))))
  ))
COMMENT (ROUTINES FOR MANIPULATING STRUCTURE)
DEFINE ((
  (BIVCHAIN (LAMBDA (N)
        (FOR NEW I := (1 N) AS NEW X IS X
          PROG2  (SETQ X (PUTNEWNODE X)))))
  ))
DEFINE ((
  (CONNECT (LAMBDA (X Y)
        (PROG NIL
            (REPLACE (NBRS X) (CONS (NODENUM Y) (NBRS X)))
            (COND
              ((NOT (EQ X Y))
                (REPLACE (NBRS Y) (CONS (NODENUM X) (NBRS Y))))))))
  ))
DEFINE ((
  (COPYSTRUC (LAMBDA (S)
        (PROG2 (SETQ LASTNODE (LASTNODE# S)) (COPY S))))
  ))
DEFINE ((
  (DISCONNECT (LAMBDA (X Y)
        (PROG NIL
            (REPLACE (NBRS X) (DELETE (NODENUM Y) (NBRS X)))
            (REPLACE (NBRS Y) (DELETE (NODENUM X) (NBRS Y))))))
  ))
DEFINE ((
  (FINDCTE (LAMBDA (N LST)
        (IF (NUMBERP N)
           THEN (IF (EQ (ID LST) @ STRUC)
                   THEN (SETQ LST (CTABLE LST))
                 ELSE NIL)
                (FOR NEW L IN LST
                  WHEN
                    (EQUAL (NODENUM L) N)
              DO    (RETURN L))
         ELSEIF (NUMBERP LST) THEN (FINDCTE LST N)
         ELSE (ERROR @ (BAD ARGUMENTS TO FINDCTE)))))
  ))
DEFINE ((
  (FIRSTOFNODES (LAMBDA (X)
        (CAR (NODES X))))
  (LASTOFNODES (LAMBDA (X)
        (CAR (LAST (NODES X)))))
  ))
DEFINE ((
  (LISTBYVALENCE (LAMBDA (S)
        (PROG (M V)
            (SETQ M (LENGTH (NODES S)))
            (RETURN (FOR NEW I := (2 999) WHILE (GREATERP M 0)
              LIST
                (SETQ V (VALENCETYPE S I))
                (SETQ M (DIFFERENCE M (LENGTH V)))
          V)))))
  ))
DEFINE ((
  (PUTFVN (LAMBDA (S N J)
        (PROG NIL
            (SETQ N (FINDCTE N (CTABLE S)))
            (REPLACE
              (NBRS N)
              (NCONC (NBRS N) (FOR NEW I := (1 J) XLIST
          @ FV)))
            (RETURN S))))
  ))
DEFINE ((
  (PUTFVS (LAMBDA (S FVP)
        (FOR NEW NI IN FVP FOR NEW NIJ IN NI AS NEW J := (1 10)
          FOR NEW NODE IN NIJ PROG2  (SETQ S (PUTFVN S NODE J)))))
  ))
DEFINE ((
  (PUTNEWNODE (LAMBDA (STRUC)
        (IF STRUC
           THEN (PROG2
                  (SETQ LASTNODE (ADD1 (LASTNODE# STRUC)))
                  (STRUCTURE
                    FROM
                    STRUC
                    CTABLE
                    =
                    (PUTNEWNODEINCT
                      (CTENTRY NODENUM = LASTNODE)
                      (CTABLE OF STRUC))
                    LASTNODE#
                    =
                    LASTNODE))
         ELSE (PROG2
                (SETQ LASTNODE (ADD1 LASTNODE))
                (STRUCTURE
                  CTABLE
                  =
                  (LIST (CTENTRY NODENUM = LASTNODE))
                  LASTNODE#
                  =
                  LASTNODE)))))
  ))
DEFINE ((
  (PUTNEWNODEINCT (LAMBDA (X Y)
        (PROG (Z)
            (SETQ Z (CAR Y))
            (REPLACE (NBRS OF Z) (CONS (NODENUM X) (NBRS Z)))
            (REPLACE (NBRS OF X) (CONS (NODENUM Z) (NBRS X)))
            (RETURN (CONS X Y)))))
  ))
DEFINE ((
  (NODEVALENCE (LAMBDA (NODE)
        (IF (NULL NODE)
           THEN (ERROR @ (NULL NODE GIVEN TO NODEVALENCE))
         ELSEIF (EQ (ID NODE) @ CTE) THEN (LENGTH (NBRS NODE))
         ELSE (NODEVALENCE (FINDCTE (CAR NODE) (CDR NODE))))))
  ))
DEFINE ((
  (VALENCETYPE (LAMBDA (S I)
        (FOR NEW NODE IN (CTABLE S)
          WHEN
            (EQUAL I (NODEVALENCE NODE))
      XLIST (NODENUM NODE))))
  ))
COMMENT (GENERAL LISP ROUTINES)
DEFINE ((
  (CARLIST (LAMBDA (L)
        (FOR NEW X IN L LIST  (CAR X))))
  (CDRLIST (LAMBDA (L)
        (FOR NEW X IN L LIST  (CDR X))))
  (LCARLIST (LAMBDA (L)
        (FOR NEW X IN L LIST  (CARLIST X))))
  (LCDRLIST (LAMBDA (L)
        (FOR NEW X IN L LIST  (CDRLIST X))))
  ))
DEFINE ((
  (COPY (LAMBDA (X)
        (COND
          ((ATOM X) X)
          (T (CONS (COPY (CAR X)) (COPY (CDR X)))))))
  ))
DEFINE ((
  (NTH (LAMBDA (L J)
        (IF (EQUAL J 1) THEN L
         ELSEIF (GREATERP J (LENGTH L))
           THEN (PRINT(LIST @ ARGUMENT J @(TO HIGH FOR NTH OF)L))
                NIL
         ELSE (FOR NEW I := (2 J) PROG2  (SETQ L (CDR L))))))
  ))
COMMENT (***** ADDITIONAL FUNCTIONS *****)
DEFINE ((
  (SINGLERINGS (LAMBDA (N)
        (LIST (SINGLERING N))))
  ))
DEFINE ((
  (INSERTMARKERS (LAMBDA (STRUC CLL L)
        (PROG NIL
            (FOR NEW CL IN CLL AS NEW NLL IN L FOR NEW PAIR IN CL
              AS NEW NL IN NLL FOR NEW N IN NL
                DO  (REPLACE
                    (ATOMTYPE (MARKERS (FINDCTE N STRUC)))
                    (CAR PAIR)))
            (RETURN STRUC))))
  ))
DEFINE ((
  (DELETE (LAMBDA (I L)
        (COND
          ((NULL L) NIL)
          ((EQUAL (CAR L) I) (CDR L))
          (T (CONS (CAR L) (DELETE I (CDR L)))))))
  ))
GSET (LASTNODE 0)
TRACE ((TRIVGRAPH SINGLERING CHORDLENGTH))
- (GSET @ CATALOG-LIST (MAKECAT TRIVALENTCODES))
UNTRACE ((TRIVGRAPH SINGLERING CHORDLENGTH))
DEFINE ((
  (EVALARGS (LAMBDA (ARGTYPE S)
        (LIST S)))
  ))
DEFINE ((
  (TRY? (LAMBDA (S)
  T))
  ))
DEFINE ((
  (PRINRAD (LAMBDA (L)
        (PROG (N)
            (PRINT L)
            (SETQ N (NUMNODES L))
            (PRINRAD0 N)
            (PRINRAD1 NIL (FOR NEW I := (N 1 -1) XLIST  I) L)
            (PRINRADOFF L))))
  ))
DEFINE ((
  (NUMNODES (LAMBDA (RAD)
        (PLUS
          (FOR NEW R IN (ATTACHEDRADS RAD)
            PLUS  (TIMES (CDR R) (NUMNODES (CAR R))))
          (IF (NULL (CENTER RAD)) THEN 0
           ELSEIF (ATOM (CENTER RAD)) THEN 1
           ELSEIF (NOT (STRUCTURE? (RADSTRUC (CENTER RAD))))
             THEN 1
           ELSE (LENGTH (NODES (RADSTRUC (CENTER RAD))))))))
  ))
DEFINE ((
  (CLEXPAND (LAMBDA (CL)
        (FOR NEW PR IN CL FOR NEW I := (1 (CDR PR))
          LIST  (CAR PR))))
  ))
DEFINE ((
  (PRINRAD1 (LAMBDA (EFF AA RAD)
        (PROG (CENT ATTACHED J X TTABLE)
            (SETQ CENT (CENTER RAD))
            (SETQ ATTACHED (CLEXPAND (ATTACHEDRADS RAD)))
            (RETURN (IF (NOT CENT)
               THEN (PRINRAD1
                      (CADR AA)
                      (CONS
                        (CAR AA)
                        (PRINRAD1 (CAR AA) (CDR AA) (CAR ATTACHED)))
                      (CADR ATTACHED))
             ELSEIF (OR
               (ATOM CENT)
               (NOT (EQ (ID (RADSTRUC CENT)) @ STRUC)))
               THEN (SETQ X (CDR AA))
                    (FOR NEW R IN ATTACHED
                      DO
                        (SETQ J (CONS (CAR X) J))
                        (SETQ X (PRINRAD1 (CAR AA) X R)))
                    (PRINENTRY
                      (CAR AA)
                      CENT
                      (IF EFF THEN (CONS EFF J) ELSE J))
                    X
             ELSE (SETQ X
                    (IF (NOT EFF) THEN AA
                     ELSE (SETQ TTABLE
                            (LIST (LIST
                              (AFFLINK CENT)
                              (CAR AA)
                              EFF)))
                          (CDR AA)))
                  (FOR NEW N IN (NODES (RADSTRUC CENT))
                    WHEN
                      (NOT (EQUAL N (AFFLINK CENT)))
                DO    (SETQ TTABLE (CONS (LIST N (CAR X)) TTABLE))
                      (SETQ X (CDR X)))
                  (FOR NEW NLIST IN (CUFFLINKS CENT)
                    FOR NEW C IN NLIST
                      AS NEW CT IS (ASSOC C TTABLE NIL)
                        DO
                          (APPEND1 CT (CAR X))
                          (SETQ X
                            (PRINRAD1 (CAR CT) X (CAR ATTACHED)))
                          (SETQ ATTACHED (CDR ATTACHED)))
                  (PRINCTAB (CTABLE (RADSTRUC CENT)) TTABLE)
                  X)))))
  ))
DEFINE ((
  (PRINCTAB (LAMBDA (CTAB TTABLE)
        (FOR NEW CT IN CTAB
          AS NEW CPRIME IS (ASSOC (NODENUM CT) TTABLE NIL)
            DO  (PRINENTRY
                (CAR CPRIME)
                (ATOMTYPE MARKERS CT)
                (APPEND
                  (CDR CPRIME)
                  (FOR NEW Y IN (NBRS CT) IF (NOT (EQ Y @ FV))
                    XLIST  (CAR (ASSOC Y TTABLE NIL))))))))
  ))
DEFINE ((
  (PRINRAD0 (LAMBDA (N)
        (PROG NIL
            (WRS GRAPHFILE)
            (VERBOS NIL)
            (OTLL 72)
            (SETQ XLATN 0)
            (TTAB 1)
            (PRINNUM 5 N)
            (TERPRI))))
  ))
DEFINE ((
  (PRINENTRY (LAMBDA (NODE TYPE NBRS)
        (PROG NIL
            (TTAB 1)
            (PRINNUM 3 NODE)
            (XTAB 1)
            (IF (ATOM TYPE) THEN (PRIN1 TYPE)
             ELSE (PRIN1 @ X)
                  (PRIN1 (SETQ XLATN (ADD1 XLATN)))
                  (SETQ XLATETABLE
                    (CONS (CONS XLATN TYPE) XLATETABLE)))
            (TTAB 9)
            (FOR NEW N IN NBRS DO  (PRINNUM 3 N))
            (TERPRI))))
  ))
DEFINE ((
  (PRINNUM (LAMBDA (W N)
        (PROG2 (XTAB (DIFFERENCE W (WIDTH N))) (PRIN1 N))))
  ))
DEFINE ((
  (WIDTH (LAMBDA (N)
        (FOR NEW X
          IN @ ((99999 6) (9999 5) (999 4) (99 3) (9 2) (0 1))
            UNTIL (GREATERP N (CAR X)) PROG2  (CADR X))))
  ))
DEFINE ((
  (PRINRADOFF (LAMBDA (L)
        (PROG NIL
            (TTAB 1)
            (PRIN1 @ STRUCTURE=)
            (PRINT L)
            (FOR NEW X IN XLATETABLE
              DO
                (PRIN1 @ X)
                (PRIN1 (CAR X))
                (PRIN1 @ =)
                (PRINT (CDR X)))
            (TTAB 1)
            (PRINT @ END*)
            (WRS @ LISPOUT)
            (OTLL 133)
            (SETQ XLATETABLE NIL))))
  ))
DEFINE ((
  (SETUPGRAPHICS (LAMBDA (FILE)
        (PROG NIL
            (SETQ GRAPHFILE FILE)
            (OPEN
              FILE
              (QUOTE ((LRECL . 80) (BLKSIZE . 3200)))
              (QUOTE OUTPUT)))))
  ))
COMMENT (PARTS COPIED FROM LOTUS (CAN BE DELETED LATER))
COMMENT (END OF COPIED PARTS FROM LOTUS)
RECORD (CHECKPERM (OBJ POBJ . ORIGPERM))
RECORD (NPL (REMPERMS . OKPERMS))
RECORD (CHECKVAL (LABELEDSOFAR LABELSLEFT . NPLLEFT))
RECORD (LABELING (LABELED UNLABELED . LSTRUC))
DEFINE ((
  (CHECKL (LAMBDA (S SB NPL)
        (IF (SETQ NPL (CHECK S SB NPL 0))
           THEN (IF (REMPERMS (NPLLEFT NPL))
                   THEN (PRINT (LIST @ CHECKL @ ERROR: S SB NPL))
                        NIL
                 ELSE (LIST (LABELING
                        LABELED
                        =
                        S
                        UNLABELED
                        =
                        SB
                        LSTRUC
                        =
                        (REVERSE (OKPERMS (NPLLEFT NPL))))))
         ELSE NIL)))
  ))
DEFINE ((
  (COMB (LAMBDA (OBJ S SB NPL LABELS)
        (IF (ZEROP LABELS) THEN (CHECKL S (APPEND SB OBJ) NPL)
         ELSEIF (EQUAL LABELS (LENGTH OBJ))
           THEN (CHECKL (APPEND OBJ S) SB NPL)
         ELSEIF (GREATERP LABELS (LENGTH OBJ)) THEN NIL
         ELSE (APPEND
                (COMBCHECK
                  (CDR OBJ)
                  (CONS (CAR OBJ) S)
                  SB
                  NPL
                  (SUB1 LABELS))
                (COMBCHECK
                  (CDR OBJ)
                  S
                  (CONS (CAR OBJ) SB)
                  NPL
                  LABELS)))))
  ))
DEFINE ((
  (COMBCHECK (LAMBDA (OBJ S SB NPL LABELS)
        (IF (SETQ NPL (CHECK S SB NPL LABELS))
           THEN (COMB
                  (DIFF OBJ (LABELEDSOFAR NPL))
                  (LABELEDSOFAR NPL)
                  SB
                  (NPLLEFT NPL)
                  (LABELSLEFT NPL))
         ELSE NIL)))
  ))
DEFINE ((
  (DIFF (LAMBDA (L1 L2)
        (FOR NEW X IN L1 WHEN
          (NOT (MEMBER X L2))
    XLIST X)))
  ))
DEFINE ((
  (CHECK (LAMBDA (S SB NPL LABELS)
        (PROG (NEWNPL OBJ POBJ OK)
            (SETQ OK (OKPERMS NPL))
            (SETQ NPL (REMPERMS NPL))
      L1    (IF (NULL NPL)
               THEN (RETURN (CHECKVAL
                      LABELEDSOFAR
                      =
                      S
                      NPLLEFT
                      =
                      (NPL OKPERMS = OK REMPERMS = NEWNPL)
                      LABELSLEFT
                      =
                      LABELS)))
            (SETQ OBJ (OBJ (CAR NPL)))
            (SETQ POBJ (POBJ (CAR NPL)))
      L3    (IF (NULL OBJ) THEN (GO L8)
             ELSEIF (MEMBER (CAR OBJ) S) THEN (GO L4)
             ELSEIF (MEMBER (CAR OBJ) SB) THEN (GO L5))
      L6    (SETQ NEWNPL
              (CONS
                (CHECKPERM FROM (CAR NPL) OBJ = OBJ POBJ = POBJ)
                NEWNPL))
      L2    (SETQ NPL (CDR NPL))
            (GO L1)
      L9    (SETQ NEWNPL NIL)
      L8    (SETQ OK (CONS (ORIGPERM (CAR NPL)) OK))
            (GO L2)
      L4    (IF (MEMBER (CAR POBJ) S) THEN (GO L7)
             ELSEIF (MEMBER (CAR POBJ) SB) THEN (RETURN NIL)
             ELSEIF (MINUSP (SETQ LABELS (SUB1 LABELS)))
               THEN (RETURN NIL))
            (SETQ S (CONS (CAR POBJ) S))
            (SETQ NPL (APPEND NEWNPL NPL))
            (IF (NULL (CDR OBJ)) THEN (GO L9))
            (SETQ NEWNPL
              (LIST (CHECKPERM
                FROM
                (CAR NPL)
                OBJ
                =
                (CDR OBJ)
                POBJ
                =
                (CDR POBJ))))
            (GO L2)
      L7    (SETQ OBJ (CDR OBJ))
            (SETQ POBJ (CDR POBJ))
            (GO L3)
      L5    (IF (MEMBER (CAR POBJ) S) THEN (GO L2)
             ELSEIF (MEMBER (CAR POBJ) SB) THEN (GO L7))
            (GO L6))))
  ))
DEFINE ((
  (LLABEL (LAMBDA (OBJECTS LABELS STRUC)
        (IF (NULL LABELS) THEN (LIST (LABELING LSTRUC = STRUC))
         ELSE (FOR NEW L1
                IN (LABELM (CAR OBJECTS) (CAR LABELS) STRUC)
                  FOR NEW L2
                    IN (LLABEL
                        (CDR OBJECTS)
                        (CDR LABELS)
                        (LSTRUC L1))
                      XLIST  (LABELING
                          FROM
                          L2
                          LABELED
                          =
                          (CONS (LABELED L1) **))))))
  ))
DEFINE ((
  (LABELM (LAMBDA (OBJECTS LABELS STRUC)
        (IF (NULL LABELS)
           THEN (LIST (LABELING UNLABELED = OBJECTS LSTRUC = STRUC))
         ELSE (FOR NEW L1 IN (LABEL1 OBJECTS (CAR LABELS) STRUC)
                FOR NEW L2
                  IN (LABELM
                      (UNLABELED L1)
                      (CDR LABELS)
                      (LSTRUC L1))
                    XLIST  (LABELING
                        FROM
                        L2
                        LABELED
                        =
                        (CONS (LABELED L1) **))))))
  ))
DEFINE ((
  (LABEL1 (LAMBDA (OBJECTS LABELS STRUC)
        (PROG (SZ SZC)
            (RETURN (IF (ZEROP LABELS)
               THEN (LIST (LABELING
                      UNLABELED
                      =
                      OBJECTS
                      LSTRUC
                      =
                      STRUC))
             ELSEIF (EQUAL LABELS (SETQ SZ (SIZE OBJECTS)))
               THEN (LIST (LABELING
                      LABELED
                      =
                      OBJECTS
                      LSTRUC
                      =
                      STRUC))
             ELSEIF (GREATERP LABELS SZ) THEN NIL
             ELSEIF (NULL (CDR (SETQ OBJECTS
               (CLASSES OBJECTS STRUC))))
               THEN (LABEL1C (CAR OBJECTS) LABELS STRUC)
             ELSE (LABEL1L OBJECTS LABELS STRUC))))))
  ))
DEFINE ((
  (LABEL1L (LAMBDA (OBJL LABELS STRUC)
        (IF (NULL OBJL)
           THEN (IF (ZEROP LABELS)
                   THEN (LIST (LABELING LSTRUC = STRUC))
                 ELSE NIL)
         ELSEIF (ZEROP LABELS)
           THEN (LIST (LABELING
                  LSTRUC
                  =
                  STRUC
                  UNLABELED
                  =
                  (PROG (R)
                      (FOR NEW O IN OBJL
                        DO  (SETQ R (COMBINE O R)))
                      (RETURN R))))
         ELSE (PROG (SZ SZC)
                  (SETQ SZ
                    (PLUS
                      (SETQ SZC (SIZE (CAR OBJL)))
                      (FOR NEW O IN (CDR OBJL) PLUS  (SIZE O))))
                  (RETURN (FOR NEW I
                    := ((MAX
                          0
                          (DIFFERENCE LABELS (DIFFERENCE SZ SZC)))
                        (MIN LABELS SZC))
                      FOR NEW L1 IN (LABEL1C (CAR OBJL) I STRUC)
                        FOR NEW L2
                          IN (LABEL1L
                              (CDR OBJL)
                              (DIFFERENCE LABELS I)
                              (LSTRUC L1))
                            XLIST  (LABELING
                                FROM
                                L2
                                LABELED
                                =
                                (COMBINE (LABELED L1) **)
                                UNLABELED
                                =
                                (COMBINE (UNLABELED L1) **))))))))
  ))
DEFINE ((
  (COMB1 (LAMBDA (OBJ LAB UNL PERMS LABELS)
        (IF (ZEROP LABELS)
           THEN (LIST (LABELING
                  LABELED
                  =
                  LAB
                  UNLABELED
                  =
                  UNL
                  LSTRUC
                  =
                  PERMS))
         ELSEIF (EQUAL LABELS (LENGTH OBJ))
           THEN (LIST (LABELING
                  LABELED
                  =
                  (APPEND OBJ LAB)
                  UNLABELED
                  =
                  UNL
                  LSTRUC
                  =
                  PERMS))
         ELSE (NCONC
                (COMB1
                  (CDR OBJ)
                  (CONS (CAR OBJ) LAB)
                  UNL
                  PERMS
                  (SUB1 LABELS))
                (COMB1
                  (CDR OBJ)
                  LAB
                  (CONS (CAR OBJ) UNL)
                  PERMS
                  LABELS)))))
  ))
DEFINE ((
  (FIXUPGROUP (LAMBDA (STRUC)
        (REPLACE
          (GROUP STRUC)
          (FINDNEWGROUP
            STRUC
            (CLASSIFYNODES
              (PROG (X)
                  (SETQ X (NODES STRUC))
                  (FOR NEW NL IN (CAR (GROUP STRUC))
                    DO  (SETQ X (DIFF X NL)))
                  (RETURN X))
              STRUC)))))
  ))
DEFINE ((
  (FINDNEWGROUP (LAMBDA (STRUC NEWORBITS)
        (PROG (NEWOBJ)
            (SETQ NEWOBJ
              (FOR NEW ORB IN NEWORBITS
                XLIST FIRST (CAR (GROUP STRUC))
                   (REVERSE ORB)))
            (RETURN (CONS
              NEWOBJ
              (FOR NEW P IN (FINDNEWGROUP1 STRUC NEWORBITS)
                WHEN
                  (NOT (EQUAL NEWOBJ (CDR P)))
            XLIST (CDR P)))))))
  ))
DEFINE ((
  (FINDNEWGROUP1 (LAMBDA (STRUC NEWORBITS)
        (FOR NEW P IN (GROUP STRUC)
          NCONC FIRST NIL
             (FINDPERMS
              (CAR NEWORBITS)
              NEWORBITS
              (CONS NIL P)
              (CONS NIL (CAR (GROUP STRUC)))
              STRUC))))
  ))
DEFINE ((
  (FINDPERMS (LAMBDA (NODES CLASSES IMS MAPPED STRUC)
        (IF (NULL CLASSES) THEN (LIST IMS)
         ELSEIF (NULL NODES)
           THEN (FINDPERMS
                  (CADR CLASSES)
                  (CDR CLASSES)
                  (CONS NIL IMS)
                  (CONS NIL MAPPED)
                  STRUC)
         ELSE (FOR NEW Y
                IN (POSSIMS
                    (CAR NODES)
                    (CAR CLASSES)
                    IMS
                    MAPPED
                    STRUC)
                  NCONC FIRST NIL
                     (FINDPERMS
                      (CDR NODES)
                      CLASSES
                      (CONS (CONS Y (CAR IMS)) (CDR IMS))
                      (CONS
                        (CONS (CAR NODES) (CAR MAPPED))
                        (CDR MAPPED))
                      STRUC)))))
  ))
DEFINE ((
  (POSSIMS (LAMBDA (X CLASS IMS MAPPED STRUC)
        (FOR NEW Y IN CLASS
          WHEN
            (NOT (MEMBER Y (CAR IMS)))
      WHEN  (FOR NEW ML IN MAPPED AS NEW IL IN IMS
              FOR NEW M IN ML AS NEW I IN IL
                AND  (EQUAL
                    (CONNECTIVITY Y I STRUC)
                    (CONNECTIVITY X M STRUC)))
      XLIST Y)))
  ))
DEFINE ((
  (CONNECTIVITY (LAMBDA (X Y STRUC)
        (FOR NEW Z IN (NBRS (FINDCTE X STRUC))
          WHEN
            (EQUAL Z Y)
      PLUS 1)))
  ))
DEFINE ((
  (GROUPCOUNT (LAMBDA (L)
        (PROG NIL
            (SETQ L (GROUPBY (QUOTE CDR) (CLCREATE L)))
            (RETURN (FOR NEW I
              := ((FOR NEW X IN L MAX  (CAR X)) 1 -1)
                XLIST  (CARLIST (ASSOC I L NIL)))))))
  ))
DEFINE ((
  (FOUND? (LAMBDA (NODE GROUP)
        (FOR NEW NL IN (CAR GROUP) AS NEW N := (1 9999999)
          DO  (IF (MEMBER NODE NL) THEN (RETURN (CONS N NL))))))
  ))
DEFINE ((
  (FINDGROUPEDGES (LAMBDA (EDGES STRUC)
        (PROG (G)
            (IF (NOT (FOR NEW EDGE IN EDGES
              AND  (AND
                  (FOUND? (NODE1 EDGE) (GROUP STRUC))
                  (FOUND? (NODE2 EDGE) (GROUP STRUC)))))
               THEN (FIXUPGROUP STRUC)
             ELSE NIL)
            (SETQ G (GROUP STRUC))
            (RETURN (NPL
              OKPERMS
              =
              (LIST (CAR G))
              REMPERMS
              =
              (FOR NEW P IN (CDR G)
                XLIST  (CHECKPERM
                    ORIGPERM
                    =
                    P
                    OBJ
                    =
                    EDGES
                    POBJ
                    =
                    (FOR NEW EDGE IN EDGES
                      LIST  (ORDPAIR
                          (IMAGE (NODE1 EDGE) (CAR G) P)
                          (IMAGE (NODE2 EDGE) (CAR G) P))))))))))
  ))
DEFINE ((
  (IMAGE (LAMBDA (NODE MAPPED IMAGES)
        (FOR NEW ML IN MAPPED AS NEW IL IN IMAGES FOR NEW M IN ML
          AS NEW I IN IL WHEN
            (EQUAL NODE M)
      DO    (RETURN I))))
  ))
DEFINE ((
  (FINDGROUPNODES (LAMBDA (OBJECTS STRUC)
        (PROG (N FOUND)
      L1    (SETQ FOUND (FOUND? (CAR OBJECTS) (GROUP STRUC)))
            (IF (NOT FOUND) THEN (FIXUPGROUP STRUC)
             ELSE (RETURN (NPL
                    OKPERMS
                    =
                    (LIST (CAR (GROUP STRUC)))
                    REMPERMS
                    =
                    (FOR NEW P IN (CDR (GROUP STRUC))
                      XLIST  (CHECKPERM
                          ORIGPERM
                          =
                          P
                          OBJ
                          =
                          (CDR FOUND)
                          POBJ
                          =
                          (CAR (NTH P (CAR FOUND))))))))
            (GO L1))))
  ))
RECORD (NODETYPE (IDNODE . NODENUMS))
DEFAULT (NODETYPE (IDNODE NODES))
MACRO ((
  (NODES? (LAMBDA (X)
        (EQ (IDNODE X) @ NODES)))
  ))
RECORD (MULTTYPE (IDMULT MULT . UNMULTED))
DEFAULT (MULTTYPE (IDMULT MULT))
MACRO ((
  (MULTTYPE? (LAMBDA (X)
        (EQ (IDMULT X) @ MULT)))
  ))
RECORD (EDGETYPE (IDEGES . NODEPRS))
DEFAULT (EDGETYPE (IDEGES EDGES))
MACRO ((
  (EDGES? (LAMBDA (X)
        (EQ (IDEGES X) @ EDGES)))
  ))
RECORD (COMBINATION (IDCOMB OBJ1 . OBJ2))
DEFAULT (COMBINATION (IDCOMB BOTH))
MACRO ((
  (COMBINATION? (LAMBDA (X)
        (EQ (IDCOMB X) @ BOTH)))
  ))
RECORD (UNCLASSED (IDUNCLASSED . OBJECTS))
DEFAULT (UNCLASSED (IDUNCLASSED ?))
MACRO ((
  (UNCLASSED? (LAMBDA (X)
        (EQ (IDUNCLASSED X) @ ?)))
  ))
RECORD (OTHERTYPE (OTHID OTHOBJECTS))
DEFAULT (OTHERTYPE (OTHID SOMETHING←ELSE))
DEFINE ((
  (SIZE (LAMBDA (OBJECTS)
        (IF (MULTTYPE? OBJECTS)
           THEN (TIMES (MULT OBJECTS) (SIZE (UNMULTED OBJECTS)))
         ELSEIF (COMBINATION? OBJECTS)
           THEN (PLUS (SIZE (OBJ1 OBJECTS)) (SIZE (OBJ2 OBJECTS)))
         ELSEIF (OR
           (NODES? OBJECTS)
           (EDGES? OBJECTS)
           (UNCLASSED? OBJECTS)) THEN (LENGTH (CDR OBJECTS))
         ELSE (PRINT (CONS OBJECTS @(BAD ARG TO SIZE))
              0)))
  ))
DEFINE ((
  (COMBINE (LAMBDA (O1 O2)
        (IF (NOT O1) THEN O2
         ELSEIF (NOT O2) THEN O1
         ELSE (COMBINATION OBJ1 = O1 OBJ2 = O2))))
  ))
DEFINE ((
  (CLASSES (LAMBDA (OBJECTS STRUC)
        (IF (COMBINATION? OBJECTS)
           THEN (NCONC
                  (CLASSES (OBJ1 OBJECTS))
                  (CLASSES (OBJ2 OBJECTS)))
         ELSEIF (NOT (UNCLASSED? OBJECTS)) THEN (LIST OBJECTS)
         ELSE (CLASSES2 (OBJECTS OBJECTS) STRUC))))
  ))
DEFINE ((
  (CLASSES2 (LAMBDA (OBJECTS STRUC)
        (PROG NIL
            (SETQ OBJECTS (GROUPCOUNT OBJECTS))
            (COMMENT FIRST CLASSIFY BY NUMBER OF OCCURANCES)
            (RETURN (FOR NEW O IN (CDR OBJECTS)
              AS NEW M := (2 999999)
                FOR NEW O2 IN (CLASSIFY3 O STRUC)
                  XLIST FIRST (CLASSIFY3 (CAR OBJECTS) STRUC)
                     (MAKEMULT M O2))))))
  ))
MACRO ((
  (CONSTO (LAMBDA (VAR VAL)
        (SETQ VAR (CONS VAL VAR))))
  ))
DEFINE ((
  (CLASSIFY3 (LAMBDA (OBJECTS STRUC)
        (PROG (N E OTH)
            (COMMENT CLASSIFY BY NODETYPE OR EDGETYPE FIRST)
            (FOR NEW X IN OBJECTS
              DO  (IF (NUMBERP X) THEN (CONSTO N X)
                 ELSEIF (AND (NUMBERP (CAR X)) (NUMBERP (CDR X)))
                   THEN (CONSTO E X)
                 ELSE (CONSTO OTH X)))
            (RETURN (* NCONC
              (MAPCAR (CLASSIFYNODES N STRUC) @ MAKENODES)
              (MAPCAR (CLASSIFYEDGES E STRUC) @ MAKEEDGES)
              (IF OTH THEN (LIST (OTHERTYPE OTHOBJECTS = OTH))
               ELSE NIL))))))
  ))
SPECIAL ((SSTRUC))
DEFINE ((
  (CLASSIFYNODES (LAMBDA (NODES SSTRUC)
        (CDRLIST (GROUPBY (FUNCTION NODEMARK) NODES))))
  ))
DEFINE ((
  (CLASSIFYEDGES (LAMBDA (EDGES SSTRUC)
        (CDRLIST (GROUPBY (FUNCTION EDGEMARK) EDGES))))
  ))
DEFINE ((
  (NODEMARK (LAMBDA (NODE)
        (PROG2
          (SETQ NODE (FINDCTE NODE SSTRUC))
          (CONS (NODEVALENCE NODE) (MARKERS NODE)))))
  ))
DEFINE ((
  (ORDPAIR (LAMBDA (X1 X2)
        (IF (LEQ X1 X2) THEN (CONS X1 X2) ELSE (CONS X2 X1))))
  ))
DEFINE ((
  (EDGEMARK (LAMBDA (EDGE)
        (ORDPAIR (NODEMARK (NODE1 EDGE)) (NODEMARK (NODE2 EDGE)))))
  ))
UNSPECIAL ((SSTRUC))
DEFINE ((
  (LABEL1C (LAMBDA (OBJECTS LABELS STRUC)
        (IF (ZEROP LABELS)
           THEN (LIST (LABELING UNLABELED = OBJECTS LSTRUC = STRUC))
         ELSEIF (EQUAL LABELS (SIZE OBJECTS))
           THEN (LIST (LABELING LABELED = OBJECTS LSTRUC = STRUC))
         ELSEIF (NODES? OBJECTS)
           THEN (LABELN (NODENUMS OBJECTS) LABELS STRUC)
         ELSEIF (EDGES? OBJECTS)
           THEN (LABELE (NODEPRS OBJECTS) LABELS STRUC)
         ELSEIF (MULTTYPE? OBJECTS)
           THEN (LABELMULT
                  (MULT OBJECTS)
                  (UNMULTED OBJECTS)
                  LABELS
                  STRUC)
         ELSE (LABELUNDEFINEDSTRUC OBJECTS LABELS STRUC))))
  ))
DEFINE ((
  (MAKEMULT (LAMBDA (M OBJ)
        (IF (ZEROP M) THEN NIL
         ELSEIF (EQUAL M 1) THEN OBJ
         ELSE (MULTTYPE MULT = M UNMULTED = OBJ))))
  ))
DEFINE ((
  (MAKENODES (LAMBDA (NODES)
        (IF (NOT NODES) THEN NIL ELSE (NODETYPE NODENUMS = NODES))))
  ))
DEFINE ((
  (MAKEEDGES (LAMBDA (EDGES)
        (IF (NOT EDGES) THEN NIL ELSE (EDGETYPE NODEPRS = EDGES))))
  ))
DEFINE ((
  (LABELMULT (LAMBDA (MULTS UNMULTED LABELS STRUC)
        (FOR NEW P
          IN (NUMPARTITIONS LABELS (SIZE UNMULTED) 0 MULTS)
            AS NEW CLP IS (CLCREATE P)
              FOR NEW L IN (LABELM UNMULTED (CDRLIST CLP) STRUC)
                XLIST  (LABELING
                    FROM
                    L
                    LABELED
                    =
                    (FOR NEW X IN ** AS NEW PR IN CLP
                      COMBINE FIRST NIL
                         (MAKEMULT (CAR PR) X))
                    UNLABELED
                    =
                    (FOR NEW X IN (LABELED L) AS NEW PR IN CLP
                      COMBINE FIRST NIL
                         (MAKEMULT (DIFFERENCE MULTS (CAR PR)) X)))))
     )
  ))
DEFINE ((
  (LABEL0A (LAMBDA (OBJECTS STRUC NPL LABELS MAKEFN)
        (FOR NEW L
          IN (IF (NOT (REMPERMS NPL))
               THEN (COMB1 OBJECTS NIL NIL (OKPERMS NPL) LABELS)
             ELSE (COMB
                    OBJECTS
                    NIL
                    (DIFF (OBJ (CAR (REMPERMS NPL))) OBJECTS)
                    NPL
                    LABELS))
            XLIST  (LABELING
                FROM
                L
                LABELED
                =
                (MAKEFN **)
                UNLABELED
                =
                (MAKEFN (DIFF OBJECTS (LABELED L)))
                LSTRUC
                =
                (STRUCTURE FROM STRUC GROUP = (LSTRUC L))))))
  ))
DEFINE ((
  (LABELN (LAMBDA (NODENUMS LABELS STRUC)
        (LABEL0A
          NODENUMS
          STRUC
          (FINDGROUPNODES NODENUMS STRUC)
          LABELS
          (FUNCTION MAKENODES))))
  ))
DEFINE ((
  (LABELE (LAMBDA (EDGES LABELS STRUC)
        (LABEL0A
          EDGES
          STRUC
          (FINDGROUPEDGES EDGES STRUC)
          LABELS
          (FUNCTION MAKEEDGES))))
  ))
DEFINE ((
  (UNCLASS (LAMBDA (OBJECTS)
        (IF (NOT OBJECTS) THEN NIL
         ELSEIF (UNCLASSED? OBJECTS) THEN (OBJECTS OBJECTS)
         ELSEIF (NODES? OBJECTS) THEN (NODENUMS OBJECTS)
         ELSEIF (EDGES? OBJECTS) THEN (NODEPRS OBJECTS)
         ELSEIF (MULTTYPE? OBJECTS)
           THEN (FOR NEW M := (1 (MULT OBJECTS))
                  APPEND  (UNCLASS (UNMULTED OBJECTS)))
         ELSEIF (COMBINATION? OBJECTS)
           THEN (APPEND
                  (UNCLASS (OBJ1 OBJECTS))
                  (UNCLASS (OBJ2 OBJECTS)))
         ELSE (PRINT (CONS OBJECTS @(ERROR ARG TO UNCLASS))
              NIL)))
  ))
DEFINE ((
  (LUNCLASS (LAMBDA (LOBJ)
        (MAPCAR LOBJ (FUNCTION UNCLASS))))
  ))
DEFINE ((
  (LLUNCLASS (LAMBDA (LLOBJ)
        (MAPCAR LLOBJ (FUNCTION LUNCLASS))))
  ))
COMMENT (FUNCTIONS FROM LOTUS WHICH NEED TO BE CHANGED)
DEFINE ((
  (PERMRADS (LAMBDA (CENT CLRADS FLAG)
        (PROG2
          (SETQ CLRADS (CLCREATE CLRADS))
          (IF (ATOM CENT)
             THEN (LIST (RADICAL
                    CENTER
                    =
                    CENT
                    ATTACHEDRADS
                    =
                    CLRADS))
           ELSEIF (STRUCFORM? CENT)
             THEN (LIST (RADICAL
                    CENTER
                    =
                    (MAKECENTER RADSTRUC = CENT)
                    ATTACHEDRADS
                    =
                    CLRADS))
           ELSE (FOR NEW L
                  IN (LABELFV
                      CENT
                      ((LAMBDA (X)
                            (IF FLAG THEN (CONS 1 X) ELSE X))
                        (CDRLIST CLRADS)))
                    XLIST  (RADICAL
                        CENTER
                        =
                        (MAKECENTER
                          AFFLINK
                          =
                          (IF FLAG THEN (CAAR (LABELED L))
                           ELSE NIL)
                          RADSTRUC
                          =
                          (LSTRUC L)
                          CUFFLINKS
                          =
                          (IF FLAG THEN (CDR (LABELED L))
                           ELSE (LABELED L)))
                        ATTACHEDRADS
                        =
                        CLRADS))))))
  ))
DEFINE ((
  (LABELEDGES (LAMBDA (STRUC LABELS)
        (FOR NEW L
          IN (LABELM
              (UNCLASSED
                OBJECTS
                =
                (FOR NEW CT IN (CTABLE STRUC)
                  FOR NEW N IN (NBRS CT)
                    WHEN
                      (LEQ (NODENUM CT) N)
                XLIST (CONS (NODENUM CT) N)))
              LABELS
              STRUC)
            XLIST  (LABELING FROM L LABELED = (LUNCLASS **)))))
  ))
DEFINE ((
  (LABELFV (LAMBDA (STRUC LABELS)
        (FOR NEW L
          IN (LABELM
              (UNCLASSED OBJECTS = (COLLECTFV STRUC))
              LABELS
              STRUC)
            XLIST  (LABELING FROM L LABELED = (LUNCLASS **)))))
  ))
DEFINE ((
  (STRUCTURESWITHATOMS (LAMBDA (CLL STRUC)
        (FOR NEW L IN (LLABELNODES STRUC (LCDRLIST CLL))
          XLIST  (INSERTMARKERS
              (COPYSTRUC (LSTRUC L))
              CLL
              (LABELED L)))))
  ))
DEFINE ((
  (ATTACHFVS (LAMBDA (FVP STRUC)
        (FOR NEW L IN (LLABELNODES STRUC FVP)
          XLIST  (PUTFVS (COPYSTRUC (LSTRUC L)) (LABELED L)))))
  ))
DEFINE ((
  (ATTACHBIVALENTS (LAMBDA (PART STRUC)
        (FOR NEW L IN (LABELEDGES STRUC (CDRLIST PART))
          XLIST  (PUTBIVS
              (COPYSTRUC (LSTRUC L))
              (CARLIST PART)
              (LABELED L)))))
  ))
DEFINE ((
  (LLABELNODES (LAMBDA (STRUC LLABELS)
        (FOR NEW L
          IN (LLABEL
              (MAPCAR (LISTBYVALENCE STRUC) @ MAKEUNCLASSED)
              LLABELS
              STRUC)
            XLIST  (LABELING FROM L LABELED = (LLUNCLASS **)))))
  ))
DEFINE ((
  (MAKEUNCLASSED (LAMBDA (X)
        (IF (NOT X) THEN NIL ELSE (UNCLASSED OBJECTS = X))))
  ))
ADVISE (((ATTACHFVS BEFORE (PROG2 (SETQ !VALUE (STRUCFORM FORM =(LIST
@ ATTACHFVS ARG1 ARG2))) (IF (STRUCFORM? ARG2) THEN (RETURN (
   EVALARGS @ (NIL FORM) !VALUE)) ELSEIF (NOT (TRY? !VALUE)) THEN (
   RETURN (LIST !VALUE)) ELSE NIL)))))
ADVISE (((STRUCTURESWITHATOMS BEFORE (PROG2 (SETQ !VALUE (STRUCFORM
   FORM = (LIST @ STRUCTURESWITHATOMS ARG1 ARG2))) (IF (STRUCFORM?
   ARG2) THEN (RETURN (EVALARGS @ (NIL FORM) !VALUE)) ELSEIF (NOT (
   TRY? !VALUE)) THEN (RETURN (LIST !VALUE)) ELSE NIL)))))
COMMENT (MORE CATALOG ENTRIES PUT IN HERE)
(LIST
  (GSET
    (QUOTE T03)
    (STRUCTURE
      NODES
      =
      @ (1 2 3)
      LASTNODE#
      =
      3
      UGRAPH
      =
      @ T03
      CTABLE
      =
      (LIST
        (CTENTRY NODENUM = 1 NBRS = @ (2 2 3 3))
        (CTENTRY NODENUM = 2 NBRS = @ (3 3 1 1))
        (CTENTRY NODENUM = 3 NBRS = @ (1 1 2 2)))))
  (GSET
    (QUOTE T21)
    (STRUCTURE
      NODES
      =
      @ (1 2 3)
      LASTNODE#
      =
      3
      UGRAPH
      =
      @ T21
      CTABLE
      =
      (LIST
        (CTENTRY NODENUM = 1 NBRS = @ (2 2 3 3))
        (CTENTRY NODENUM = 2 NBRS = @ (1 1 3))
        (CTENTRY NODENUM = 3 NBRS = @ (1 1 2)))))
  (GSET
    (QUOTE T22)
    (FOR NEW X IN (CATALOG3 @ (4))
      FOR NEW Y IN (LABEL1 @ (NODES 1 2 3 4) 2 X)
        AS NEW Z IS (COPYSTRUC (LSTRUC Y))
          XLIST
            (CONNECT
              (FINDCTE (CAR (NODENUMS (LABELED Y))) Z)
              (FINDCTE (CADR (NODENUMS (LABELED Y))) Z))
      Z))
  (GSET
    (QUOTE T41)
    (LIST
      (STRUCTURE
        LASTNODE#
        =
        5
        UGRAPH
        @ T41KITE
        CTABLE
        =
        (LIST
          (CTENTRY NODENUM = 1 NBRS = @ (2 3 4 5))
          (CTENTRY NODENUM = 2 NBRS = @ (1 3 5))
          (CTENTRY NODENUM = 3 NBRS = @ (1 2 4))
          (CTENTRY NODENUM = 4 NBRS = @ (1 3 5))
          (CTENTRY NODENUM = 5 NBRS = @ (1 2 4))))
      (STRUCTURE
        LASTNODE#
        =
        5
        UGRAPH
        @ T41SCOOP
        CTABLE
        =
        (LIST
          (CTENTRY NODENUM = 1 NBRS = @ (2 2 4 5))
          (CTENTRY NODENUM = 2 NBRS = @ (1 1 3))
          (CTENTRY NODENUM = 3 NBRS = @ (2 4 5))
          (CTENTRY NODENUM = 4 NBRS = @ (1 3 5))
          (CTENTRY NODENUM = 5 NBRS = @ (1 3 4))))
      (STRUCTURE
        LASTNODE#
        =
        5
        UGRAPH
        @ T41FAN
        CTABLE
        =
        (LIST
          (CTENTRY NODENUM = 1 NBRS = @ (2 4 5 5))
          (CTENTRY NODENUM = 2 NBRS = @ (1 3 3))
          (CTENTRY NODENUM = 3 NBRS = @ (2 2 4))
          (CTENTRY NODENUM = 4 NBRS = @ (1 3 5))
          (CTENTRY NODENUM = 5 NBRS = @ (1 1 4))))
      (STRUCTURE
        LASTNODE#
        =
        5
        UGRAPH
        @ T41RING
        CTABLE
        =
        (LIST
          (CTENTRY NODENUM = 1 NBRS = @ (2 2 5 5))
          (CTENTRY NODENUM = 2 NBRS = @ (1 1 3))
          (CTENTRY NODENUM = 3 NBRS = @ (2 4 4))
          (CTENTRY NODENUM = 4 NBRS = @ (3 3 5))
          (CTENTRY NODENUM = 5 NBRS = @ (1 1 4))))
      (STRUCTURE
        LASTNODE#
        =
        5
        UGRAPH
        @ T41HOURGLASS
        CTABLE
        =
        (LIST
          (CTENTRY NODENUM = 1 NBRS = @ (2 3 4 5))
          (CTENTRY NODENUM = 2 NBRS = @ (1 3 3))
          (CTENTRY NODENUM = 3 NBRS = @ (1 2 2))
          (CTENTRY NODENUM = 4 NBRS = @ (1 5 5))
          (CTENTRY NODENUM = 5 NBRS = @ (1 4 4))))))
))))))
ADVISE (((CATALOG3 BEFORE (IF (EQUAL ARG1 @ (0 3)) THEN (RETURN (LIST
   T03)) ELSEIF (EQUAL ARG1 @ (2 2)) THEN (RETURN T22) ELSEIF (EQUAL
   ARG1 @ (4 1)) THEN (RETURN T41) ELSEIF (EQUAL ARG1 @ (2 1)) THEN (
   RETURN (LIST T21))))))
DEFINE ((
  (TD (LAMBDA (VL J)
        (IF (NOT VL) THEN 0
         ELSE (PLUS (TIMES J (CAR VL)) (TD (CDR VL) (ADD1 J))))))
  ))
DEFINE ((
  (M2/2 (LAMBDA (N)
        (SUB1 (QUOTIENT N 2))))
  ))
DEFINE ((
  (MAXREST (LAMBDA (VL J)
        (FOR NEW X IN (CDR VL) AS NEW K := ((ADD1 J) 9999999)
          PLUS  (TIMES X (M2/2 K)))))
  ))
DEFINE ((
  (LOOPPARTITIONS1 (LAMBDA (P VL J)
        (IF (NOT VL) THEN (LIST NIL)
         ELSE (FOR NEW PJ
                := ((MAX 0 (DIFFERENCE P (MAXREST VL J)))
                    (MIN P (TIMES (M2/2 J) (CAR VL))))
                  AS NEW RESTL
                    IS (LOOPPARTITIONS1
                        (DIFFERENCE P PJ)
                        (CDR VL)
                        (ADD1 J))
                      FOR NEW THISPART
                        IN (FVPART1 PJ (CAR VL) (M2/2 J))
                          FOR NEW RESTPART IN RESTL
                            XLIST  (CONS THISPART RESTPART)))))
  ))
DEFINE ((
  (JLIST (LAMBDA (LL N)
        (IF (NOT LL) THEN NIL
         ELSEIF (NOT (CDR LL)) THEN (LIST (CAR (NTH (CAR LL) N)))
         ELSE (CONS
                (CAR (NTH (CAR LL) N))
                (JLIST (CDDR LL) (ADD1 N))))))
  ))
DEFINE ((
  (LPROWS (LAMBDA (LPP VL)
        (PROG2
          (SETQ LPP (CONS NIL LPP))
          (FOR NEW S := (4 999999)
            AS NEW V
              IN (* CONS
                  (CAR VL)
                  (FOR NEW V2 IN (CDR VL) AS NEW PL IN LPP
                    LIST  (DIFFERENCE V2 (*PLUS PL))))
                AS LPP IS (IF LPP THEN (CDR LPP) ELSE NIL)
                  LIST  (CONS V (JLIST LPP (M2/2 S)))))))
  ))
DEFINE ((
  (LOOPPARTITIONS (LAMBDA (P VL)
        (FOR NEW LPP IN (LOOPPARTITIONS1 P (CDDR VL) 4)
          AS NEW ROWS IS (LPROWS LPP VL)
            FOR NEW K := (0 (TD (CDR VL) 3))
              FOR NEW BP
                IN (NUMPARTITIONS (CAR VL) (PLUS P K) 1 999999)
                  AS NEW CLBP IS (CLCREATE BP)
                    FOR NEW EL IN (CLPARTS CLBP K)
                      FOR NEW LPL
                        IN (CLPARTITIONSL
                            (CLDIFF CLBP EL)
                            (CDRLIST ROWS))
                          XLIST  (LOOPPARTITION
                              LOOPVL
                              =
                              (CONS
                                (*PLUS (CDAR ROWS))
                                (MAPCAR (CDR ROWS) @ *PLUS))
                              EDGELABELS
                              =
                              EL
                              LOOPLABELS
                              =
                              LPL))))
  ))
DEFINE ((
  (CLPARTITIONSL (LAMBDA (CL LL)
        (IF (NOT LL) THEN (LIST NIL)
         ELSE (FOR NEW FP IN (CLPARTS CL (*PLUS (CAR LL)))
                AS NEW RPL
                  IS (CLPARTITIONSL (CLDIFF CL FP) (CDR LL))
                    FOR NEW TP IN (CLPARTLP1 FP (CAR LL) 1)
                      FOR NEW RP IN RPL XLIST  (CONS TP RP)))))
  ))
DEFINE ((
  (CLPARTLP1 (LAMBDA (CL ROW N)
        (IF (NOT ROW) THEN (LIST NIL)
         ELSEIF (ZEROP (CAR ROW))
           THEN (CLPARTLP1 CL (CDR ROW) (ADD1 N))
         ELSE (FOR NEW EP IN (CLPARTS CL (TIMES N (CAR ROW)))
                AS NEW RPL
                  IS (CLPARTLP1 (CLDIFF CL EP) (CDR ROW) (ADD1 N))
                    FOR NEW EEP IN (CL=PARTS EP (CAR ROW) N)
                      FOR NEW RP IN RPL
                        XLIST  (APPEND (CLCREATE EEP) RP)))))
  ))
DEFINE ((
  (KLOOPEDRINGS (LAMBDA (P VL)
        (IF (ZEROP P) THEN (NOLOOPEDRINGS VL)
         ELSE (FOR NEW LOOPPART IN (LOOPPARTITIONS P VL)
                FOR NEW STRUC IN (NOFV-RINGS (LOOPVL LOOPPART))
                  NCONC FIRST NIL
                     (ATTACHBIVS&LOOPS
                      (EDGELABELS LOOPPART)
                      (LOOPLABELS LOOPPART)
                      STRUC)))))
  ))
DEFINE ((
  (ATTACHBIVS&LOOPS (LAMBDA (EL LL STRUC)
        (IF (NOT EL)
           THEN (FOR NEW L2 IN (LLABELNODES STRUC (LCDRLIST LL))
                  XLIST  (PUTLOOPS
                      (COPYSTRUC (LSTRUC L2))
                      (LCARLIST LL)
                      (LABELED L2)))
         ELSE (FOR NEW L1 IN (LABELEDGES STRUC (CDRLIST EL))
                FOR NEW L2
                  IN (LLABELNODES (LSTRUC L1) (LCDRLIST LL))
                    XLIST  (PUTLOOPS
                        (PUTBIVS
                          (COPYSTRUC (LSTRUC L2))
                          (CARLIST EL)
                          (LABELED L1))
                        (LCARLIST LL)
                        (LABELED L2))))))
  ))
DEFINE ((
  (PUTLOOPS (LAMBDA (STRUC LPS LNODES)
        (PROG2
          (FOR NEW LOBJ IN LNODES AS NEW LLABS IN LPS
            FOR NEW OBJ IN LOBJ AS NEW LAB IN LLABS
              FOR NEW LPPR IN LAB FOR NEW I := (1 (CDR LPPR))
                FOR NEW NODE IN OBJ
                  DO  (SETQ STRUC (PUTBIVN STRUC NODE (CAR LPPR))))
          STRUC)))
  ))
DEFINE ((
  (PUTBIVN (LAMBDA (STRUC NODE NBIVS)
        (IF (ZEROP NBIVS) THEN STRUC
         ELSE (PROG (B)
                  (SETQ B (BIVCHAIN NBIVS))
                  (CONNECT
                    (CAR (CTABLE B))
                    (SETQ NODE (FINDCTE NODE (CTABLE STRUC))))
                  (CONNECT (CAR (LAST (CTABLE B))) NODE)
                  (NCONC (CTABLE STRUC) (CTABLE B))
                  (REPLACE (LASTNODE# STRUC) (LASTNODE# B))
                  (RETURN STRUC)))))
  ))
DEFINE ((
  (PUTBIVS (LAMBDA (S L LST)
        (PROG2
          (FOR NEW X IN LST AS NEW N IN L FOR NEW E IN X
            DO  (PUTBIVE S E N))
          S)))
  ))
DEFINE ((
  (PUTBIVE (LAMBDA (S E N)
        (IF (ZEROP N) THEN S
         ELSE (PROG (B N1 N2)
                  (SETQ B (BIVCHAIN N))
                  (CONNECT
                    (CAR (CTABLE B))
                    (SETQ N1 (FINDCTE (CAR E) (CTABLE S))))
                  (CONNECT
                    (CAR (LAST (CTABLE B)))
                    (SETQ N2 (FINDCTE (CDR E) (CTABLE S))))
                  (DISCONNECT N1 N2)
                  (NCONC (CTABLE S) (CTABLE B))
                  (REPLACE (LASTNODE# S) (LASTNODE# B))
                  (RETURN S)))))
  ))
ADVISE (((ATTACHBIVS&LOOPS BEFORE (PROG2 (SETQ !VALUE (STRUCFORM
   FORM = (LIST @ ATTACHBIVS&LOOPS ARG1 ARG2 ARG3))) (IF (STRUCFORM?
   ARG3) THEN (RETURN (EVALARGS @ (NIL NIL FORM) !VALUE)) ELSEIF (NOT
   (TRY? !VALUE)) THEN (RETURN (LIST !VALUE)) ELSE NIL)))))
ADVISE (((ATTACHBIVALENTS BEFORE (PROG2 (SETQ !VALUE (STRUCFORM FORM
   = (LIST @ ATTACHBIVALENTS ARG1 ARG2))) (IF (STRUCFORM? ARG2) THEN (
   RETURN (EVALARGS @ (NIL FORM) !VALUE)) ELSEIF (NOT (TRY? !VALUE))
   THEN (RETURN (LIST !VALUE)) ELSE NIL)))))
SPECIAL ((MOLNUM STARTPRINTAT TYPECOUNT))
DEFINE(( (ISOMERS (LAMBDA(U CL) (PROG ()
(SETQ MOLNUM 1) (SETQ TYPECOUNT NIL)
(MOLECULES CL U)
(EJECT)
(FOR NEW X IN TYPECOUNT DO
(PRINC (CDR X)) (TTAB 10) (PRINT (CAR X)))
))))))))
DEFINE ((
  (GENMOL (LAMBDA (CL)
        (PROG (MINDEG RESULT NATOMS)
            (IF (EQUAL 1 (SETQ NATOMS (CLCOUNT CL)))
THEN (PRINTSTRUCS (PERMRADS (CAAR CL) NIL NIL))   (RETURN NIL)
             ELSEIF (EVENP NATOMS)
               THEN (FOR NEW PART
                      IN (CL=PARTS CL 2 (QUOTIENT NATOMS 2))
                        FOR NEW RADS IN (GENRADLIST PART)
                          DO  (SETQ RESULT
                              (APPEND
(PRINTSTRUCS  (PERMRADS NIL RADS NIL)  )
                                RESULT)))
                    (SETQ MINDEG 3)
             ELSE (SETQ MINDEG 2))
            (SETQ NATOMS (SUB1 NATOMS))
            (FOR NEW PAIR IN CL AS NEW CENTER IS (CAR PAIR)
              AS NEW NEWCL IS (CLDIFF CL (LIST (CONS CENTER 1)))
                FOR NEW DEG
                  := (MINDEG (MIN (VALENCE CENTER) NATOMS))
                    FOR NEW P
                      IN (CLPARTITIONSN
                          NEWCL
                          DEG
                          1
                          (QUOTIENT NATOMS 2))
                        FOR NEW RADS IN (GENRADLIST P)
                          DO  (SETQ RESULT
                              (NCONC
(PRINTSTRUCS   (PERMRADS CENTER RADS NIL)   )
                                RESULT)))
            (RETURN RESULT))))
  ))
DEFINE ((
  (PRINTSTRUCS (LAMBDA (L)
        (FOR NEW X IN L AS MOLNUM := (MOLNUM 99999)
           WHEN (GREATERP (ADD1 MOLNUM) STARTPRINTAT)
          DO (SETQ TYPECOUNT  (CLINSERT (UGOFMOL X) TYPECOUNT))
            (TTAB 5)
            (PRINRAD X)
            )))
  ))
DEFINE(((UGOFMOL (LAMBDA(MOL)(CLCREATE(UGOFRAD MOL))))))))))
DEFINE(((UGOFRAD (LAMBDA(RAD)
  (FOR NEW RP IN (ATTACHEDRADS RAD)FOR NEW I := (1 (CDR RP)) APPEND
    FIRST (IF (OR (ATOM (CENTER RAD))
                  (NOT (STRUCTURE? (RADSTRUC (CENTER RAD)))))
THEN NIL ELSE (LIST(UGRAPH(RADSTRUC(CENTER RAD)))))
        (UGOFRAD (CAR RP))))))))))))
SPECIAL((LONGPRINTOUT))
GSET(LONGPRINTOUT NIL))
GSET(STARTPRINTAT 0)
DEFINE ((
  (PRINRAD (LAMBDA (L)
        (PROG (N)
  (COND (LONGPRINTOUT (PRINT L)) (T NIL))
            (SETQ N (NUMNODES L))
            (PRINRAD0 N)
            (PRINRAD1 NIL (FOR NEW I := (N 1 -1) XLIST  I) L)
    (PRINRADOFF (COND (LONGPRINTOUT L) (T MOLNUM))) )))))))))))
  ))
DEFINE(((PRINOB(LAMBDA()(FOR NEW X IN OBLIST WHEN(CDR X)
  DO (TTAB 1)(PRIN1 X)(TTAB 25)(PRINC (CDR X)) (TERPRI))))))))))
RECLAIM NIL
OPEN (CYC SYSFILE OUTPUT)
CHKPOINT (CYC)
CLOSE (CYC)
GSET (TTLIST NIL)
DEFINE ((
  (TT (LAMBDA (L)
        (FOR NEW X IN L
          WHEN
            (NOT (MEMBER X TTLIST))
      DO    (TIMETOT (LIST X))
            (SETQ TTLIST (CONS X TTLIST)))))
  ))
TRACE ((GENMOL MOLECULES SUPERATOMPARTITIONS SUPERATOMS RINGS
   FVPARTITIONS RINGSKELETONS NOFV-RINGS DAISIES NOLOOPEDRINGS
   BIVALENTPARTITIONS ISOMERS KLOOPEDRINGS PERMRADS ATTACHLOOPS
   CATALOG STRUCWITH2NODES CATALOG3 DAISY SINGLERING BIVCHAIN
   GROUPRADS COPYSTRUC FINDCTE ATTACHBIVS&LOOPS PUTLOOPS PUTBIVE
   PUTBIVN PUTBIVS PUTFVN PUTFVS SINGLERINGS INSERTMARKERS EVALARGS
   TRY? PRINRAD FIXUPGROUP FINDNEWGROUP FINDGROUPEDGES
   FINDGROUPNODES PERMRADS LABELEDGES LABELFV STRUCTURESWITHATOMS
   ATTACHFVS ATTACHBIVALENTS LLABELNODES))
TT ((CLCREATE GENMOL MOLECULES SUPERATOMPARTITIONS SUPERATOMS RINGS